home *** CD-ROM | disk | FTP | other *** search
/ Mac100% 1998 November / MAC100-1998-11.ISO.7z / MAC100-1998-11.ISO / ｵﾝﾗｲﾝｿﾌﾄ定点観測 / ﾕｰﾃｨﾘﾃｨ / Mops 3.2.sea / Mops 3.2 / Mops source / PPC source / pString < prev    next >
Text File  |  1998-06-17  |  8KB  |  372 lines
  1. ¥ String class.
  2.  
  3. syscall Munger
  4. syscall IUMagString
  5.  
  6.  
  7.    $ D    constant    RET            ¥ Carriage return character
  8.  
  9. : $ER
  10.     setFwind
  11.     cr ." size: " .  ."   pos: " .  ."   lim: " .
  12.     89 die   ;
  13.  
  14. ' $er  -> $err
  15.  
  16.  
  17. : $=  { addr1 len1 addr2 len2 -- }
  18.     addr1  addr2  len1  len2  IUMagString
  19. ;
  20.  
  21.  
  22. : NOPEN    ." (not open)"  ;
  23.  
  24. syscall Munger
  25.  
  26.  
  27. :class    STRING    super{ handle }        general
  28.  
  29. record
  30. {    var    SIZE
  31.     var    POS
  32.     var    LIM
  33.     int    FLAGS
  34. }
  35.  
  36. private
  37.  
  38. :m $err:        ¥ called when we find something out of bounds.
  39.     ." size: " get: size .
  40.     ."   pos: "  get: pos .h
  41.     ."   lim: "  get: lim .h
  42.     89 die
  43. ;m
  44.  
  45. :m $chk:
  46.     get: pos 0<
  47.     get: lim 0<                or
  48.     get: pos  get: lim  u>    or
  49.     get: lim  get: size u>    or  IF  $err: self  THEN
  50. ;m
  51.  
  52. public
  53.  
  54. :m COPYTO:    ¥ Redefinition of COPYTO: which will disallow a size change
  55.             ¥ on the copy.  I found it was fairly easy to do this
  56.             ¥ accidentally, and get into random crash territory.
  57.     copyto: super
  58.     1 put: flags   ;m
  59.  
  60.  
  61. :m MARK_ORIGINAL:
  62. ¥ Overrides the above check.  Marks a copy as original, so we can change its
  63. ¥ size.  We hope we know what we're doing.  At least this is a long name
  64. ¥ which could hardly get typed by accident!!
  65.  
  66.     clear: flags   ;m
  67.  
  68.  
  69. :m HANDLE:        ¥ this method returns the handle - replaces get: in super
  70.     inline{ ^base @}  ;m
  71.  
  72. :m POS:        ¥ ( -- pos )
  73.     inline{ get: pos}  ;m
  74.  
  75. :m >POS:    ¥ ( newpos -- )
  76.     inline{ put: pos}  ;m
  77.  
  78. :m LIM:        ¥ ( -- lim )
  79.     inline{ get: lim}  ;m
  80.  
  81. :m >LIM:    ¥ ( newlim -- )
  82.     inline{ put: lim}  ;m
  83.  
  84. :m LEN:        ¥ ( -- length )
  85.     inline{ get: lim  get: pos -}  ;m
  86.  
  87. :m >LEN:    ¥ ( newlength -- )
  88.     inline{ get: pos  +  put: lim}  ;m
  89.  
  90.  
  91. :m SKIP:    ¥ ( n -- )  Increments POS by n.
  92.     inline{ +: pos}  ;m
  93.  
  94. :m MORE:    ¥ ( n -- )  Increments LIM by n.
  95.     inline{ +: lim}  ;m
  96.  
  97. :m START:    ¥ Sets POS to 0 (the start of the string).
  98.     inline{ clear: pos}  ;m
  99.  
  100. :m BEGIN:    ¥ Sets POS and LIM to 0, ready to begin some operation.
  101.     inline{ clear: pos  clear: lim}  ;m
  102.  
  103. :m END:        ¥ Sets POS and LIM to the end of the string.
  104.     inline{ get: size  dup  put: pos  put: lim}  ;m
  105.  
  106. :m NOLIM:    ¥ Sets LIM to the end of the string.
  107.     inline{ get: size put: lim}  ;m
  108.  
  109. :m RESET:    ¥ Sets POS to 0, and LIM to the end.
  110.     inline{ clear: pos  get: size  put: lim}  ;m
  111.  
  112. :m STEP:    ¥ Steps down the string, by setting POS to LIM and
  113.             ¥ then setting LIM to the end.
  114.     inline{ get: lim put: pos get: size put: lim}  ;m
  115.  
  116. :m <STEP:    ¥ Backward step.  Sets LIM to POS, then POS to 0.
  117.     inline{ get: pos put: lim clear: pos}  ;m
  118.  
  119.  
  120. :m NEW:
  121.     0 new: super        ¥ allocate a handle of (initially) zero size
  122.     clear: size  clear: pos  clear: lim  clear: flags  ;m
  123.     
  124. :m ?NEW:
  125.     ^base @  nilH <> ?EXIT  new: self  ;m
  126.  
  127. :m SIZE:    ¥ ( -- size )
  128.     inline{ get: size}  ;m
  129.  
  130. :m SETSIZE:    ¥ ( newsize -- )
  131.     get: flags  IF  94 die  THEN        ¥ Can't do that on a string copy
  132.     ?new: self
  133.     dup  setsize: super  put: size  reset: self  ;m
  134.  
  135. :m CLEAR:
  136.     ?new: self  0 setsize: self  ;m
  137.  
  138. :m GET:        ¥ ( -- addr len ).  Gets the active part of the string.
  139.     $chk: self
  140.     ptr: self  get: pos  +  get: lim  get: pos  -  ;m
  141.  
  142. :m ALL:        ¥ ( -- addr len )    Gets all the string, ignoring POS and LIM.
  143.     ptr: self  size: self  ;m
  144.  
  145. :m 1ST:        ¥ ( -- c )  Returns the char at POS.
  146.     inline{ ^base @ @ get: pos + c@}  ;m
  147.  
  148. :m ^1ST:    ¥ ( -- addr )  Returns the addr of the char at POS.
  149.     inline{ ^base @ @ get: pos +}  ;m
  150.  
  151. private
  152.  
  153. :m MUNGER:  { addr1 len1 addr2 len2 -- offs }
  154.         ¥ Interface to the Toolbox Munger utility
  155.     $chk: self
  156.     get: flags  IF  94 die  THEN        ¥ Can't do that on a string copy
  157.     ^base @
  158.     get: pos
  159.     addr1 len1  addr2 len2
  160.     Munger
  161.     size: super  put: size  ;m
  162.  
  163. public
  164.  
  165. :m UC:        ¥ ( -- addr len )  Converts string to upper case and gets it.
  166.     get: self  2dup  upper  ;m
  167.  
  168. :m >UC:        ¥ ( -- )    Converts active part of string to upper case
  169.     get: self  upper  ;m
  170.  
  171. :m PUT: { addr len -- }
  172.         ¥ Replaces entire string with replacement string.  Does NEW:
  173.         ¥ if not already done.
  174.     ?new: self  clear: pos
  175.     0 -1  addr len  munger: self  put: lim  ;m
  176.  
  177. :m ->:  { str ¥ hstate -- }
  178.         ¥ Replaces self with the active part of string str.  We assume
  179.         ¥ the type, and early bind.  As the replacement may cause the
  180.         ¥ Mem Manager to move things, we lock str for the duration.
  181.  
  182.     str getState: class_as> string  -> hstate
  183.     str lock: class_as> string
  184.     str get: class_as> string   put: self
  185.     hstate   str setState: class_as> string   ;m
  186.  
  187.     
  188. :m INSERT:  { addr len -- }
  189.     ?new: self
  190.     addr 0 addr len  munger: self  put: pos
  191.     len +: lim  ;m
  192.  
  193.  
  194. :m  CHINSERT:    ¥ ( c -- )  Inserts the given character.
  195.     pad c!  pad 1 insert: self   ;m
  196.  
  197.  
  198. :m $INSERT:  { str ¥ hstate -- }
  199.         ¥ Inserts the active text from the given relocatable
  200.         ¥ string, using early binding.  As the memory manager could 
  201.         ¥ move the source string to make room for the increase in 
  202.         ¥ length of SELF, we lock the source string for the
  203.         ¥ operation, then restore its previous state.
  204.  
  205.     str getState: class_as> string  -> hstate
  206.     str lock: class_as> string
  207.     str get: class_as> string  insert: self
  208.     hstate  str setState: class_as> string  ;m
  209.  
  210.  
  211. :m ADD: { addr len -- }
  212.     end: self
  213.     addr len  insert: self  ;m
  214.  
  215.  
  216. :m $ADD:  { str ¥ hstate -- }
  217.     str getState: class_as> string  -> hstate
  218.     str lock: class_as> string
  219.     str get: class_as> string  add: self
  220.     hstate  str setState: class_as> string  ;m
  221.  
  222.  
  223. :m +:        ¥ ( char -- )  Appends a char to end of string
  224.     pad c!  pad 1 add: self  ;m
  225.  
  226.  
  227. :m  OVWR:  { addr len -- }
  228.  
  229. ¥ Overwrites the active part of SELF with the string ( addr len ).
  230. ¥ Copying stops at the end of the active part, or when len characters
  231. ¥ have been transferred.  POS is incremented by the number of chars
  232. ¥ transferred.  This operation is faster than normal replacement, as the
  233. ¥ length of SELF cannot change, so Munger is not called.
  234.  
  235.     addr  get: self  len min  dup -> len  cmove
  236.     len +: pos   ;m
  237.  
  238.  
  239. :m  CHOVWR:    ¥ ( c -- )  Overwrites the first char of the active
  240.         ¥ part of the string ( if any ) by the char c.
  241.     get: self  IF  c!  1 skip: self  else  2drop  THEN   ;m
  242.  
  243.  
  244. :m  $OVWR:    ¥ ( str -- )
  245.     get: class_as> string  ovwr: self    ;m
  246.  
  247.  
  248. private
  249. :m  (REPL):  { len1 addr2 len2 -- }
  250.     0 len1  addr2 len2  munger: self  put: pos  ;m
  251.  
  252. public
  253.  
  254. :m REPL:  { addr len -- }
  255.     len: self  addr len  (repl): self
  256.     get: pos  put: lim  ;m
  257.  
  258. :m $REPL:  { str ¥ hstate -- }
  259.     str getState: string  -> hstate  
  260.     str lock: string
  261.     str get: string  repl: self
  262.     hstate  str setState: string  ;m
  263.  
  264.  
  265. :m DELETE:    ¥ Deletes the active part of the string.
  266.         ¥ LIM is then set equal to POS.
  267.     0 0  repl: self  ;m
  268.  
  269.  
  270. :m DELETEN:  { n -- }
  271.         ¥ From POS, deletes n characters or up to LIM,
  272.         ¥ whichever comes first.  LIM is reduced by the number
  273.         ¥ of characters deleted.
  274.     len: self  n  min  dup -> n
  275.     0 0  (repl): self
  276.     n negate  +: lim  ;m
  277.  
  278.  
  279. :m PRINT:
  280.     nil?: self
  281.     IF  Nopen  ELSE  get: self  type  THEN  ;m
  282.  
  283. ¥ :m   =: { theobj -- }
  284. ¥        ¥ Assigns this string to any object that accepts ( addr len )
  285. ¥    get: self  put: theobj  ;m
  286.  
  287. :m FILL:    ¥ ( c -- )
  288.     get: self  rot  fill  ;m
  289.  
  290.  
  291. ¥ SEARCH: and CHSEARCH: are somewhat interim.  Class String+ provides more
  292. ¥ efficient versions which also include case handling.  But these versions
  293. ¥ are short, and may be adequate for many needs.
  294.  
  295. :m SEARCH:    ¥ ( addr len -- b )
  296.     0 0  munger: self
  297.     dup 0< IF  drop  false  ELSE  put: lim  true  THEN  ;m
  298.  
  299. :m CHSEARCH:    ¥ ( c -- b )
  300.     pad c!  pad 1  search: self  ;m
  301.  
  302. :m <CHSEARCH:   { c ¥ strt ^1st addr -- b }
  303.     $chk: self
  304.     ^base @ @ dup -> strt  get: pos +  -> ^1st
  305.     strt  get: lim +  -> addr
  306.     BEGIN
  307.         -1 ++> addr
  308.         addr ^1st u<    IF  false  EXIT  THEN
  309.         addr c@ c =        IF  addr strt -  put: pos  true  EXIT  THEN
  310.     AGAIN
  311. ;m
  312.  
  313.  
  314. :m DUMP:  { ¥ offs svCurs -- }
  315.     nil?: self  if  Nopen  EXIT  THEN
  316.     curs? -> svCurs  -curs
  317.     all: self  swap .h .h  5 spaces
  318.     ." pos: "  pos: self .h  2 spaces
  319.     ." lim: "  lim: self .h  cr
  320.     pos: self 5 - 0 max  -> offs
  321.     all: self  swap offs +  swap offs -  80 min  bounds
  322.     DO  i c@  bl 126 within?
  323.         NIF  ret = IF  $ A6  ELSE  $ D7  THEN
  324.         THEN
  325.         emit
  326.     LOOP  cr
  327.     pos: self  offs - spaces  & P  emit  cr
  328.     lim: self  offs -
  329.     dup 80 < IF  spaces  & L  emit  ELSE  drop  THEN
  330.     ^1st: self  len: self  0 max  $ 140  min  dump
  331.     svCurs -> curs?  ;m
  332.  
  333. :m RD:    reset: self  dump: self  ;m        ¥ Handy, and short to type!
  334.  
  335. ;class
  336.  
  337.  
  338. endload
  339.  
  340.  
  341. ¥ =========== the current test block ============
  342.  
  343. :f TEST { ¥ x -- }
  344. dbgr
  345.     cr cr ." hi there one and all!" cr  1 2 3
  346.     begin
  347.         query cr
  348.         begin
  349.             rest nip 0>
  350.         while
  351.             defined?
  352.             if        execute
  353.             else
  354.             dbgr
  355.                     number  CDP 1024 -  swap  dump
  356.             then
  357.         repeat
  358.         .s cr
  359.     again
  360. ;f
  361.  
  362. :f quit  test  ;f        ¥ temp so we can catch errors!
  363.  
  364. endload
  365.  
  366. +echo
  367.  
  368. : q db
  369.     temp{ string s }
  370.     " hello" put: s
  371.     dump: s  ;
  372.